home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / gfaxpert.lzh / GFAXPERT.LIB / STANHIME.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  8.0 KB  |  293 lines
  1. ' *** STANHIME.LST ***         (delete this line)
  2. '
  3. ' ==============================================================================
  4. ' ********************
  5. ' ***         .GFA ***
  6. ' ********************
  7. ' *** this program runs in High or Medium resolution
  8. '
  9. ' ------------------------------------------------------------------------------
  10. '                             *** Initiation ***
  11. '
  12. DEFWRD "a-z"                    ! word variables (-32768 to +32767) default !!
  13. @initio
  14. '
  15. ' @title.screen("TITLE",".. .... 1990",32)        ! activate in finished program
  16. ' ON BREAK GOSUB break                            ! activate in finished program
  17. '
  18. ' ------------------------------------------------------------------------------
  19. '                            *** Main Program ***
  20. '
  21. '
  22. '
  23. EDIT                            ! use this while developing program
  24. ' @exit                         ! use this in finished program
  25. '
  26. ' ------------------------------------------------------------------------------
  27. '                     *** Standard Globals and Array ***
  28. '
  29. > PROCEDURE initio
  30.   LOCAL w,h,n
  31.   '
  32.   CLS
  33.   @high.med.mode
  34.   '
  35.   @get.path(default.path$)
  36.   '
  37.   physbase%=XBIOS(2)            ! physical screen
  38.   logbase%=XBIOS(3)             ! logical screen
  39.   '
  40.   IF XBIOS(4)=2
  41.     high.res!=TRUE
  42.     scrn.x.max=WORK_OUT(0)                              ! 639 (regular monitor)
  43.     scrn.y.max=WORK_OUT(1)                              ! 399
  44.     ~GRAF_HANDLE(char.width,char.height,w,h)            ! 8x16 font
  45.     scrn.col.max=DIV(SUCC(scrn.x.max),char.width)       ! 80
  46.     scrn.lin.max=DIV(SUCC(scrn.y.max),char.height)      ! 25
  47.   ELSE
  48.     med.res!=TRUE
  49.     scrn.x.max=WORK_OUT(0)                              ! 639 (regular monitor)
  50.     scrn.y.max=WORK_OUT(1)                              ! 199
  51.     ~GRAF_HANDLE(char.width,char.height,w,h)            ! 8x8 font
  52.     scrn.col.max=DIV(SUCC(scrn.x.max),char.width)       ! 80
  53.     scrn.lin.max=DIV(SUCC(scrn.y.max),char.height)      ! 25
  54.   ENDIF
  55.   '
  56.   IF high.res!
  57.     white=0
  58.     black=1
  59.     red=black           ! change red and green to black if in High resolution
  60.     green=black
  61.     VSETCOLOR 1,0
  62.     DEFTEXT black,0,0,13
  63.   ELSE
  64.     white=0             ! default Medium colors
  65.     black=1
  66.     red=2
  67.     green=3
  68.     DEFTEXT black,0,0,6
  69.   ENDIF
  70.   '
  71.   ' *** create Standard Array color.index()
  72.   ' *** use this array to convert a VDI color-index into a 'SETCOLOR'-index
  73.   DIM color.index(3)
  74.   IF high.res!
  75.     RESTORE col.index.high
  76.     col.index.high:
  77.     DATA 0,1,1,1
  78.   ENDIF
  79.   IF med.res!
  80.     RESTORE col.index.med
  81.     col.index.med:
  82.     DATA 0,3,1,2
  83.   ENDIF
  84.   FOR n=0 TO 3
  85.     READ color.index(n)
  86.   NEXT n
  87.   '
  88.   ' *** default palette
  89.   IF high.res!
  90.     VSETCOLOR 1,0
  91.   ENDIF
  92.   IF med.res!
  93.     @standard.med.colors
  94.   ENDIF
  95.   '
  96.   on!=TRUE
  97.   off!=FALSE
  98.   '
  99.   bel$=CHR$(7)
  100.   '
  101.   return$=CHR$(13)
  102.   esc$=CHR$(27)
  103.   help$=CHR$(0)+CHR$(98)
  104.   undo$=CHR$(0)+CHR$(97)
  105.   '
  106.   interpreter$="\GFABASIC.PRG"  ! change path if necessary
  107.   run.only$="\GFABASRO.PRG"     ! Run-Only Interpreter
  108.   start.gfa$="\START.GFA"       ! 'Shell' for GFA-programs
  109.   start.prg$="\GFASTART.PRG"    ! 'Shell' for compiled GFA-programs
  110.   '
  111. RETURN
  112. ' **********
  113. '
  114. ' ------------------------------------------------------------------------------
  115. '                          *** Standard Functions ***
  116. '
  117. DEFFN center$(text$)=SPACE$((scrn.col.max-LEN(text$))/2)+text$
  118. DEFFN rev$(txt$)=CHR$(27)+"p"+txt$+CHR$(27)+"q"
  119. '
  120. ' ------------------------------------------------------------------------------
  121. '                         *** Standard Procedures ***
  122. '
  123. > PROCEDURE high.med.mode
  124.   ' *** uses Procedure Exit
  125.   LOCAL m$,button
  126.   IF XBIOS(4)=0
  127.     SOUND 1,10,12,4,25
  128.     SOUND 1,10,6,4,25
  129.     SOUND 1,10,12,4,50
  130.     SOUND 1,0
  131.     m$="Sorry, use|High or Medium|resolution for|this program"
  132.     ALERT 3,m$,1," OK ",button
  133.     @exit
  134.   ENDIF
  135. RETURN
  136. ' **********
  137. '
  138. > PROCEDURE get.path(VAR default.path$)
  139.   ' *** return default path (current drive and folder)
  140.   ' *** example - A:\GAMES\
  141.   ' *** WARNING : Procedure returns path$ only after CHDIR path$, else A:\
  142.   ' ***                          (even if program not in main directory !!)
  143.   LOCAL default.drive,default.drive$
  144.   CLR default.path$
  145.   default.drive=GEMDOS(&H19)
  146.   default.drive$=CHR$(default.drive+65)
  147.   default.path$=DIR$(default.drive+1)
  148.   IF default.path$<>""
  149.     default.path$=default.drive$+":"+default.path$+"\"
  150.   ELSE
  151.     default.path$=default.drive$+":\"
  152.   ENDIF
  153. RETURN
  154. ' **********
  155. '
  156. > PROCEDURE standard.med.colors
  157.   ' *** standard-colors for Medium resolution
  158.   LOCAL n,col$,r,g,b
  159.   RESTORE col.data
  160.   FOR n=0 TO 3
  161.     READ col$
  162.     r=VAL(LEFT$(col$))
  163.     g=VAL(MID$(col$,2,1))
  164.     b=VAL(RIGHT$(col$))
  165.     VSETCOLOR n,r,g,b
  166.   NEXT n
  167.   '
  168.   col.data:
  169.   DATA 777,000,700,060
  170. RETURN
  171. ' **********
  172. '
  173. > PROCEDURE title.screen(title$,datum$,height)
  174.   ' *** standard title-screen
  175.   ' *** uses Standard Globals and Standard Procedure Return.key
  176.   LOCAL x,y,col,lin,name$,x1,y1,x2,y2,i
  177.   CLS
  178.   HIDEM
  179.   DEFTEXT black,8,0,height
  180.   x=(scrn.x.max-LEN(title$)*height/2)/2
  181.   y=scrn.y.max/2
  182.   TEXT x,y,title$
  183.   LET name$="© Han Kempen"      ! that's me
  184.   col=(scrn.col.max-12)/2
  185.   lin=scrn.lin.max/2+6
  186.   PRINT AT(col,lin);name$
  187.   x1=(col-2)*8
  188.   y1=(lin-1)*char.height-4
  189.   x2=x1+LEN(name$)*8+16
  190.   y2=y1+char.height+8
  191.   BOX x1,y1,x2,y2
  192.   DEFLINE 1,3
  193.   DRAW x1+3,y2+2 TO x2+2,y2+2 TO x2+2,y1+3
  194.   LINE x1+3,y2+1,x2+2,y2+1
  195.   PRINT AT(col,lin+2);datum$
  196.   @return.key
  197.   COLOR black
  198.   DEFLINE 1,1
  199.   FOR i=0 TO y
  200.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  201.   NEXT i
  202.   COLOR white
  203.   FOR i=y DOWNTO 0
  204.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  205.   NEXT i
  206.   COLOR black
  207.   CLS
  208. RETURN
  209. ' **********
  210. '
  211. > PROCEDURE return.key
  212.   ' *** wait for <Return>
  213.   ' *** after pressing any other key, flashing 'RETURN' is turned off
  214.   ' *** uses Standard Globals
  215.   LOCAL w1$,w2$,temp$,in$
  216.   CLR in$
  217.   REPEAT
  218.   UNTIL INKEY$=""
  219.   GET 0,scrn.y.max-char.height,scrn.x.max,scrn.y.max,temp$
  220.   w1$="<RETURN>"
  221.   w2$=SPACE$(8)
  222.   PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  223.   WHILE in$=""                              ! wait for any key
  224.     PAUSE 30
  225.     SWAP w1$,w2$
  226.     PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  227.     in$=INKEY$
  228.   WEND
  229.   PUT 0,scrn.y.max-char.height,temp$,3    ! restore screen
  230.   WHILE in$<>return$                      ! wait for <Return>
  231.     in$=INKEY$
  232.   WEND
  233. RETURN
  234. ' **********
  235. '
  236. > PROCEDURE break
  237.   ' *** activate in main program with : ON BREAK GOSUB break
  238.   ' *** do not use while developing program !
  239.   LOCAL m$,k
  240.   ON BREAK CONT
  241.   m$="*** Break ***|Continue,|Run again|or Quit"
  242.   ALERT 3,m$,1,"CONT|RUN|QUIT",k
  243.   SELECT k
  244.   CASE 1
  245.     ON BREAK                            ! true break possible for emergency
  246.     m$="Freeze current|screen (press|any key to|continue)"
  247.     ALERT 2,m$,2,"YES|NO",k
  248.     IF k=1
  249.       REPEAT
  250.       UNTIL LEN(INKEY$) OR MOUSEK
  251.     ENDIF
  252.     ON BREAK GOSUB break
  253.   CASE 2
  254.     RUN
  255.   CASE 3
  256.     @exit
  257.   ENDSELECT
  258. RETURN
  259. ' **********
  260. '
  261. > PROCEDURE exit
  262.   ' *** exit program
  263.   CLS
  264.   IF EXIST(interpreter$) OR EXIST(run.only$)
  265.     ' *** program was run from (Run-Only) Interpreter
  266.     IF EXIST(start.gfa$)
  267.       CHAIN start.gfa$          ! back to 'shell'-program
  268.     ELSE
  269.       EDIT                      ! no shell
  270.     ENDIF
  271.   ELSE IF EXIST(start.gfa$)
  272.     ' *** can't find interpreter, but here is the 'shell'-program
  273.     CHAIN start.gfa$
  274.   ELSE IF EXIST(start.prg$)
  275.     ' *** compiled program started from shell
  276.     CHAIN start.prg$            ! back to shell
  277.   ELSE
  278.     ' *** compiled program
  279.     SYSTEM                      ! no shell
  280.   ENDIF
  281. RETURN
  282. ' **********
  283. '
  284. ' ------------------------------------------------------------------------------
  285. '                               *** Procedures ***
  286. '
  287. '
  288. '
  289. '
  290. ' ------------------------------------------------------------------------------
  291. '                                *** The End ***
  292. ' ==============================================================================
  293.